perm filename MORSED.F4[HAK,HPM] blob sn#004570 filedate 1974-06-17 generic text, type T, neo UTF8
00100	      DIMENSION LPHA(36),MORS(36)
00200	      DATA LNUM/36/
00300		COMMON/PARS/AVCS,AVWS,AVOM,AVAM
00400		DATA AVSP/3.5/,AVWS/7./,AVOM/3.5/,AVAM/7./
00500		DIMENSION IMAR(7),ISPA(7),ITYP(7),IMTYP(7)
00600	      DATA LPHA/'E','T','I','A','N','M','S','U','R','W','D'
00700	     1,'K','G','O','H','V','F','L','P','J','B','X','C','Y','Z','Q'
00800	     2,'5','4','3','2','1','6','7','8','9','0'/
00900	      DATA MORS/1,2,4,5,7,8,13,14,16,17,22,23,25,26,40,41,43,49
01000	     1,52,53,67,68,70,71,76,77,121,122,125,134,161,202,229
01100	     2,238,241,242/
01200	   10 CALL LETR(IMAR,ISPA,ITYP,IMTYP,N)
01300		NLEF=N
01400		CALL MAXM(N,IMAR,MIN,MAX)
01500		IF(2*MIN.GT.MAX) GO TO 1
01600		AVOM=AVOM*0.5+0.5*MIN
01700		AVAM=AVAM*0.5+0.5*MAX
01800	    1 DO 2 I=1,N
02000	 	IF(IMAR(I)*2.0.GT.AVOM+AVAM) GO TO 3
02100		IMTYP(I)=1
02200		AVOM=AVOM*0.9+0.1*IMAR(I)
02300		GO TO 2
02400	    3 IMTYP(I)=2
02500		AVAM=AVAM*0.9+0.1*IMAR(I)
02600	    2 CONTINUE
02700	   12 ICHR=0
02800		DO 4 I=1,N
02900	    4 ICHR=ICHR*3+IMTYP(I)
03000		I=1
03100		J=LNUM
03200	    6 IF(I.GT.J) GO TO 5
03300		K=(I+J)/2
03400		IF(MORS(K)-ICHR) 9,8,7
03500	    7 J=K-1
03600		GO TO 6
03700	    9 I=K+1
03800		GO TO 6
03900	    8 IF(ITYP(1).EQ.4) CALL CRET
04000		IF(ITYP(1).EQ.3) CALL CHAR(' ')
04100		CALL CHAR(LPHA(K))
04200		NLEF=NLEF-N
04300		DO 20 I=1,N
04400		IF(ITYP(I).EQ.1) AVCS=AVCS*0.99-0.01*ISPA(I)
04500		IF(ITYP(I).EQ.2) AVWS=AVWS*0.99-0.01*ISPA(I)
04600	   20 CONTINUE
04700		IF(NLEF.EQ.0) GO TO 10
04800		DO 11 I=1,NLEF
04900		K=I+N
05000		IMAR(I)=IMAR(K)
05100		ISPA(I)=ISPA(K)
05200		ITYP(I)=ITYP(K)
05300	   11 IMTYP(I)=IMTYP(K)
05400		N=NLEF
05500		GO TO 12
05600	    5 CALL MAXM(N-1,ISPA(2),MAX,MIN)
05700		DO 13 I=2,N
05800		IF(ISPA(I).EQ.MAX) GO TO 14
05900	   13 CONTINUE
06000	   14 ITYP(I)=2
06100		N=I-1
06200		GO TO 12
06300		END
06400	
06500		SUBROUTINE LETR(IMAR,ISPA,ITYP,IMTYP,N)
06600		DIMENSION IMAR(7),ISPA(7),ITYP(7),IMTYP(7)
06700		INTEGER MARK(10),SPACE(10),SPATYP(10)
06800		DATA ILAS/0/
06900		COMMON/PARS/ AVCS,AVWS,AVOM,AVAM
07000	    5 SPATYP(ILAS+1)=0
07100		CALL NEXT(-100,SPACE(ILAS+1),IFY)
07150		IF(SPACE(ILAS+1).GT.0) GO TO 5
07200		IF(IFY.NE.2) GO TO 4
07300		SPACE(ILAS+1)=-AVWS
07400		SPATYP(ILAS+1)=4
07500	    4 CALL NEXT(200,MARK(ILAS+1),IFY)
07600		IF(IFY.EQ.2) GO TO 5
07700		ILAS=ILAS+1
07800		IMTYP(ILAS)=0
07900		IF(ILAS.LT.6) GO TO 5
08000		CALL MAXM(ILAS-1,SPACE(2),MAX,MIN)
08100		AVCS=AVCS*0.95-0.05*MIN
08200		IF(-4*MIN.GT.-MAX) AVWS=AVWS*0.7-0.3*MAX
08300		DO 6 I=1,ILAS
08400		IF(SPATYP(I).NE.0) GO TO 6
08500		SPATYP(I)=1
08600		IF(-SPACE(I).GT.0.6*(AVCS+AVWS)) SPATYP(I)=2
08700		IF(SPACE(I).EQ.MAX) SPATYP(I)=2
08800		IF(SPACE(I).GT.1.3*AVWS) SPATYP(I)=3
08900		IF(SPACE(I).EQ.MIN) SPATYP(I)=1
09000	    6 CONTINUE
09010		IMAR(1)=MARK(1)
09020		ISPA(1)=SPACE(1)
09030		ITYP(1)=SPATYP(1)
09100		DO 7 I=2,ILAS
09200		IF(SPATYP(I).NE.1) GO TO 8
09300		IMAR(I)=MARK(I)
09400		ISPA(I)=SPACE(I)
09500		ITYP(I)=SPATYP(I)
09600	    7 CONTINUE
09700	    8 N=I-1
09800		DO 9 J=I,ILAS
09900		K=J-I+1
10000		SPATYP(K)=SPATYP(J)
10100		IF(J.NE.I) SPATYP(K)=0
10200		SPACE(K)=SPACE(J)
10300	    9 MARK(K)=MARK(J)
10400		ILAS=ILAS-N
10500		RETURN
10600		END
10700	
10800	      SUBROUTINE MAXM(N,IR,MIN,MAX)
10900	      DIMENSION IR(N)
11000	      MAX=IR(1)
11100	      MIN=MAX
11200	      DO 1 I=1,N
11300	      IF(IR(I).LT.MIN) MIN=IR(I)
11400	      IF(IR(I).GT.MAX) MAX=IR(I)
11500	    1 CONTINUE
11600	      RETURN
11700	      END
11800	
11900	      SUBROUTINE NEXT(MAX,LEN,IFY)
12000		COMMON/HREE/IGG
12100	      DIMENSION IN(200)
12200	      DATA IG/1/,I/1/,LEG/200/
12300	      IFY=1
12400	      GO TO (1,2),IG
12500	    1 CALL MORSIN(IN,LEG)
12600	      IG=2
12700	    2 IF(IGG.NE.0.AND.IGG.NE.I) GO TO 4
12800	      IF(IABS(IN(I)).GT.IABS(MAX)) GO TO 3
12900	      CALL SLEEP(0)
13000	      GO TO 2
13100	    4 LEN=IN(I)
13200	      I=MOD(I,LEG)+1
13300	      IF(LEN*MAX.LT.0) GO TO 2
13400	      RETURN
13500	    3 LEN=IN(I)
13600	      IFY=2
13700	      CALL SLEEP(0)
13800	      RETURN
13900	      END